home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
unixport
/
defsystem.lsp.orig
< prev
next >
Wrap
Lisp/Scheme
|
1986-06-26
|
20KB
|
528 lines
;;;; DEFSYSTEM.LSP
;;;;
;;;; --- System Generation Tool for Kyoto Common Lisp ---
(in-package 'lisp)
(export '(defsystem defkcl defkcn))
(in-package 'compiler)
(in-package 'system)
;;; *KCL-HOME-DIRECTORY*
(defvar *kcl-home-directory* #"^") ; Change!!
;(defvar *kcl-home-directory* #"../") ; Change!!
(defvar *port-directory*
(make-pathname :directory (append (pathname-directory
*kcl-home-directory*)
(list #+aosvs "port"
#+unix "unixport"))
:name nil :type nil))
(defvar *lsp-directory*
(make-pathname :directory (append (pathname-directory
*kcl-home-directory*)
(list "lsp"))
:name nil :type nil))
#+unix
(defvar *include.h*
(make-pathname :directory (append (pathname-directory
*kcl-home-directory*)
(list "h"))
:name "include" :type "h"))
(defvar *ob-directory*
(make-pathname :directory (append (pathname-directory
*kcl-home-directory*)
(list #+aosvs "ob" #+unix "o"))
:name nil :type nil))
(setq *print-case* :downcase)
(defvar *object-files*
#+aosvs
'("main" "alloc" "gbc"
"ffalt" "short" "interrupt"
"eval" "macros" "frame" "error" "reference" "assignment"
"conditional" "catch" "lex" "prog" "block" "bds"
"multival" "mapfun" "let" "iteration" "toplevel" "cmpaux"
"array" "bind" "cfun" "character" "file" "list"
"pathname" "package" "predicate" "print" "read" "backq"
"structure" "sequence" "string" "symbol" "typespec"
"big" "number" "num_arith" "num_co" "num_comp" "num_sfun" "num_log"
"num_pred" "num_rand" "earith"
"hash" "filesystem" "time"
"fasl_loader" "fasl_pass1" "fasl_pass2" "fasl_reloc" "fasl_table"
"fasl_io" "fasload"
"bitop"
"savemem" "sys"
"process"
"format")
#+unix
'("main" "alloc" "gbc"
"bitop"
"typespec"
"eval" "macros" "lex" "bds" "frame"
"predicate"
"reference" "assignment" "bind" "let"
"conditional" "block" "iteration" "mapfun"
"prog" "multival" "catch"
"symbol" "cfun" "cmpaux" "package"
"big" "number" "num_pred" "num_comp" "num_arith" "num_sfun"
"num_co" "num_log" "num_rand" "earith"
"character" "char_table"
"sequence" "list" "hash" "array" "string" "structure"
"toplevel"
"file" "read" "backq" "print" "format" "pathname" "unixfsys"
"unixfasl"
"error"
"unixtime" "unixsys" "unixsave" "unixint"))
(defvar *lsp-object-files*
'("defmacro" "evalmacros" "top" "module"))
(defvar *all-libraries*
'("predlib" "setf"
"arraylib" "assert" "defstruct" "describe"
"iolib" "listlib" "mislib" "numlib"
"packlib" "seq" "seqlib" "trace"))
(defun change-file-type (file type)
(make-pathname :directory (pathname-directory file)
:name (pathname-name file)
:type type))
(defun strip-file-type (file) (change-file-type file nil))
(defun search-tree (x tree)
(loop
(cond ((equal x tree) (return t))
((atom tree) (return nil))
((search-tree x (car tree)) (return t))
(t (setq tree (cdr tree))))))
(defmacro defsystem (system-name files &rest body)
(if (atom system-name)
`(make-system ',system-name ',files ',body)
`(apply #'make-system
',(car system-name) ',files ',body
',(cdr system-name))))
(defun make-system (system-name files initial-forms
&key (libraries nil)
(system system-name)
(raw-system
(merge-pathnames
(format nil "raw_~A" system-name)
system))
(top-level nil)
(command-file
(format nil
#+aosvs "make_~A.cli" #+unix "make_~A"
system-name))
(sys-file
(format nil "sys_~A.c" system-name))
(init-file
(format nil "init_~A.lsp" system-name))
#+aosvs (use-console t))
#+aosvs (setq system (change-file-type system "pr"))
#+aosvs (setq raw-system (change-file-type raw-system "pr"))
(cond ((eq libraries t) (setq libraries *all-libraries*))
(t
(dolist (library libraries)
(unless (member (string library) *all-libraries*
:test #'string-equal)
(error "~S is not a library." library)))
;; Reorder the libraries.
(setq libraries
(mapcan #'(lambda (library)
(if (member library libraries
:test #'string-equal :key #'string)
(list library)
nil))
*all-libraries*))))
(setq files
(mapcar #'(lambda (file)
(if (symbolp file)
(string-downcase (symbol-name file))
file))
files))
(when (symbolp system)
(setq system (string-downcase (symbol-name system))))
(when (symbolp raw-system)
(setq raw-system (string-downcase (symbol-name raw-system))))
(unless (search-tree 'si:init-system initial-forms)
(setq initial-forms
(append initial-forms (list '(si:init-system)))))
(when top-level
(setq initial-forms
(append initial-forms
(list `(defun si:top-level () (,top-level))))))
;; Make the sys file.
(setq sys-file (change-file-type sys-file "c"))
(with-open-file (stream sys-file :direction :output)
#+unix
(format stream "#include \"~A\"~%~%" (namestring *include.h*))
#+aosvs
(format stream "#include \"include.h\"~%~%")
(format stream "static object fasl_data;~%~%")
(format stream "init_init()~%{~%")
(format stream " enter_mark_origin(&fasl_data);~%")
(format stream " fasl_data = Cnil;~%~%")
(format stream " load(\"~A\");~%"
(namestring (merge-pathnames "export.lsp" *lsp-directory*)))
(dolist (library *lsp-object-files*)
(format stream
" fasl_data = read_fasl_data(\"~A\");~%"
(namestring
(merge-pathnames (change-file-type library
#+aosvs "fasl" #+unix "o")
*lsp-directory*)))
(format stream " init_~A(NULL, 0, fasl_data);~%" library))
(format stream " load(\"~A\");~%"
(namestring (merge-pathnames "autoload.lsp" *lsp-directory*)))
(format stream "}~%~%")
(format stream "init_system()~%{~%")
(dolist (library libraries)
(format stream
" printf(\"Initializing ~A... \"); fflush(stdout);~%"
library)
(format stream
" fasl_data = read_fasl_data(\"~A\");~%"
(namestring
(merge-pathnames (change-file-type library
#+aosvs "fasl" #+unix "o")
*lsp-directory*)))
(format stream " init_~A(NULL, 0, fasl_data);~%" library)
(format stream
" printf(\"\\n\"); fflush(stdout);~%"))
(format stream "~%")
(dolist (file files)
(format stream
" printf(\"Initializing ~A... \"); fflush(stdout);~%"
(pathname-name file))
(format stream
" Vpackage->s.s_dbind = user_package;~%")
(format stream
" fasl_data = read_fasl_data(\"~A\");~%"
(namestring
(change-file-type file #+aosvs "fasl" #+unix "o")))
(format stream " init_~A(NULL, 0, fasl_data);~%"
(string-downcase (pathname-name file)))
(format stream
" printf(\"\\n\"); fflush(stdout);~%"))
(format stream
"~% Vpackage->s.s_dbind = user_package;~%")
(format stream "}~%"))
;; Make the init file.
(with-open-file (stream init-file :direction :output)
(mapcar #'(lambda (package)
(unless (eq package (find-package 'keyword))
(prin1 `(IN-PACKAGE ,(package-name package)) stream)
(terpri stream)))
(list-all-packages))
(prin1 `(IN-PACKAGE ,(package-name *package*)) stream)
(terpri stream)
(prin1 (if #+aosvs use-console #+unix t
#+aosvs
`(PROGN
,@initial-forms
(FORMAT T "~&~%Type in (SAVE \"~A\") and (BYE).~%~%"
,(namestring (strip-file-type system))))
`(PROGN
,@initial-forms
(SAVE ,(namestring (strip-file-type system)))
(BYE)))
stream)
(terpri stream))
;; Make the command file.
(with-open-file (stream command-file :direction :output)
#+aosvs
;; Set the search list.
(format stream
"push;prompt pop~%~%~
searchlist :USR:DGC :UTIL ~A~%~%"
(namestring (make-pathname
:directory
(pathname-directory *kcl-home-directory*)
:name "h")))
#+aosvs
;; Change the current directory.
(format stream "directory ~A~%~%" (namestring (truename "=")))
;; Compile the sys file.
(format stream
#+aosvs
"write Compiling ~A~%~
cc/opt=2/nomap/noinclude/noextl &~%~
AOSVS/define MAXPAGE/define=2048 VSSIZE/define=2048 &~%~
~A~%~%"
#+unix
"#~%~%~
if ({ vax }) then~%~
set MACHINE = VAX~%~
endif~%~%~
if ({ sun }) then~%~
set MACHINE = SUN~%~
endif~%~%~
echo Compiling ~A~%~
cc -c -D$MACHINE -DMAXPAGE=2048 -DVSSIZE=2048 ~A~%~%"
(namestring sys-file)
#+aosvs (namestring (strip-file-type sys-file))
#+unix (namestring sys-file))
;; Link the raw system.
#+aosvs
(format stream
#+aosvs
"write Linking~%~
ccl/storage=131072/task=2/mtop=34/nounx/o=~A &~%~
~{~A ~}&~%~
~A &~%~
~{~A ~}&~%~
~{~A ~}~%~%"
(namestring (strip-file-type raw-system))
(mapcar #'(lambda (object-file)
(namestring
(strip-file-type
(merge-pathnames object-file *ob-directory*))))
*object-files*)
(namestring (strip-file-type sys-file))
(mapcar #'(lambda (library)
(namestring
(merge-pathnames library *lsp-directory*)))
(append *lsp-object-files* libraries))
(mapcar #'(lambda (file) (namestring (strip-file-type file)))
files))
#+unix
(format stream
"echo Linking~%~
cc -o ~A \\~%~
~{~A ~}\\~%~
~A \\~%~
~{~A ~}\\~%~
~{~A ~}\\~%~
-lm ~%~%"
(namestring raw-system)
(mapcar #'(lambda (object-file)
(namestring
(change-file-type
(merge-pathnames object-file *ob-directory*)
"o")))
*object-files*)
(namestring (change-file-type sys-file "o"))
(mapcar #'(lambda (library)
(namestring
(change-file-type
(merge-pathnames library *lsp-directory*)
"o")))
(append *lsp-object-files* libraries))
(mapcar #'(lambda (file)
(namestring (change-file-type file "o")))
files))
;; Save the system.
#+aosvs
(if (not use-console)
(format stream
"process/default/block/ioc/priority=3/input=~A &~%~
~A ~A~%~%"
(namestring init-file)
(namestring (strip-file-type raw-system))
(namestring *port-directory*))
(format stream "write Invoke ~A and load ~A."
(namestring (strip-file-type raw-system))
(namestring init-file)))
#+unix
(format stream
"~A ~A < ~A~%~%"
(namestring raw-system)
(namestring *port-directory*)
(namestring init-file)))
(format t "Command file is ~A.~%" (namestring command-file))
)
(defvar *cmpnew-directory*
(make-pathname :directory (append (pathname-directory
*kcl-home-directory*)
(list "cmpnew"))
:name nil :type nil))
(defvar *lisp-implementation-version*
(multiple-value-bind (sec min hour date month year)
(get-decoded-time)
(format nil "~A ~D, ~D"
(case month
(1 "January") (2 "Feburary") (3 "March")
(4 "April") (5 "May") (6 "June")
(7 "July") (8 "August") (9 "September")
(10 "October") (11 "November") (12 "December"))
date year)))
(defmacro defkcl (&key (system-name "kcl")
#+aosvs
(system system-name)
#+unix
(system (format nil "saved_~a" (string system-name)))
(raw-system (format nil "raw_~a" (string system-name)))
(include-compiler t)
(libraries t)
&aux (*package* *package*)
)
(in-package 'system)
(setq *check-time* nil)
`(defsystem (,system-name
:top-level kcl-top-level
:libraries ,libraries
:system ,system
:raw-system ,raw-system
#+aosvs :use-console #+aosvs t)
,(if include-compiler
(list (merge-pathnames "cmpinline" *cmpnew-directory*)
(merge-pathnames "cmputil" *cmpnew-directory*)
(merge-pathnames "cmptype" *cmpnew-directory*)
(merge-pathnames "cmpbind" *cmpnew-directory*)
(merge-pathnames "cmpblock" *cmpnew-directory*)
(merge-pathnames "cmpcall" *cmpnew-directory*)
(merge-pathnames "cmpcatch" *cmpnew-directory*)
(merge-pathnames "cmpenv" *cmpnew-directory*)
(merge-pathnames "cmpeval" *cmpnew-directory*)
(merge-pathnames "cmpflet" *cmpnew-directory*)
(merge-pathnames "cmpfun" *cmpnew-directory*)
(merge-pathnames "cmpif" *cmpnew-directory*)
(merge-pathnames "cmplabel" *cmpnew-directory*)
(merge-pathnames "cmplam" *cmpnew-directory*)
(merge-pathnames "cmplet" *cmpnew-directory*)
(merge-pathnames "cmploc" *cmpnew-directory*)
;(merge-pathnames "cmpmain" *cmpnew-directory*)
(merge-pathnames "cmpmap" *cmpnew-directory*)
(merge-pathnames "cmpmulti" *cmpnew-directory*)
(merge-pathnames "cmpspecial" *cmpnew-directory*)
(merge-pathnames "cmptag" *cmpnew-directory*)
(merge-pathnames "cmptop" *cmpnew-directory*)
(merge-pathnames "cmpvar" *cmpnew-directory*)
(merge-pathnames "cmpvs" *cmpnew-directory*)
(merge-pathnames "cmpwt" *cmpnew-directory*))
nil)
(allocate 'cons 90)
(si:init-system)
(gbc t)
,@(if include-compiler
`((load ,(merge-pathnames "cmpmain.lsp" *cmpnew-directory*))
(gbc t)
(load ,(merge-pathnames "lfun_list.lsp" *cmpnew-directory*))
(gbc t)
(load ,(merge-pathnames "cmpopt.lsp" *cmpnew-directory*))
(gbc t)
(defun compile-file (&rest args
&aux (*print-pretty* nil)
(*package* *package*))
(compiler::init-env)
(apply 'compiler::compile-file1 args))
(defun compile (&rest args &aux (*print-pretty* nil))
(apply 'compiler::compile1 args))
(defun disassemble (&rest args &aux (*print-pretty* nil))
(apply 'compiler::disassemble1 args)))
nil)
(setq *old-top-level* (symbol-function 'si:top-level))
(defun kcl-top-level ()
(when (> (si:argc) 1) (setq *system-directory* (si:argv 1)))
,@(if include-compiler
'((when (>= (si:argc) 5)
(let ((si::*quit-tag* (cons nil nil))
(si::*quit-tags* nil)
(si::*break-level* 0)
(si::*break-env* nil)
(si::*ihs-base* 1)
(si::*ihs-top* 1)
(si::*current-ihs* 1)
(*break-enable* nil))
(si:error-set
'(let ((flags (si:argv 4)))
(setq si:*system-directory* (pathname (si:argv 1)))
(compile-file
(si:argv 2)
:output-file (si:argv 3)
#+unix :o-file
#+aosvs :fasl-file
(case (schar flags 1)
(#\0 nil) (#\1 t) (t (si:argv 5)))
:c-file
(case (schar flags 2)
(#\0 nil) (#\1 t) (t (si:argv 6)))
:h-file
(case (schar flags 3)
(#\0 nil) (#\1 t) (t (si:argv 7)))
:data-file
(case (schar flags 4)
(#\0 nil) (#\1 t) (t (si:argv 8)))
#+aosvs :ob-file
#+aosvs
(case (schar flags 5)
(#\0 nil) (#\1 t) (t (si:argv 9)))
:system-p
(if (char-equal (schar flags 0) #\S) t nil))))
(bye))))
nil)
(format t "KCl (Kyoto Common Lisp) ~A~%"
,*lisp-implementation-version*)
(in-package 'user)
(funcall *old-top-level*))
(defun lisp-implementation-version () ,*lisp-implementation-version*)
(setq *modules* nil)
(gbc t)
(si:reset-gbc-count)
(allocate 'cons 200)
#+unix (defun si:top-level () (kcl-top-level))
#+unix (si:save-system ,system)
#+unix (bye)
#+aosvs (format t "~%Use SI:SAVE-SYSTEM instead of SAVE.~%")
)
)
(defmacro defkcn (&rest r)
`(defkcl :include-compiler nil
:system-name kcn
,@r))